\ Evolution of an array-defining word Ham 12:00 11/01/92 \ The following screens contain a series of definitions of \ an array-defining word. After each version are some \ examples that exercise the words just defined. \ Michael Ham \ Version 1 Ham 12:00 11/01/92 : ARRAY CREATE ( # - ) WSIZE * ALLOT ( space for # singles ) DOES> ( n <adr> - adr ) SWAP WSIZE * + ; \ nth slot adr \ This array allocates the number of slots specified, but does \ NOT initialize them to zero. In the stack comment for the \ DOES> part, the <adr> refers to the address that DOES> puts \ on the stack (the parameter field address of the defined word.\ Examples of use: 8 ARRAY TOM \ defines TOM as having 8 slots = 8*WSIZE bytes 125 5 TOM ! \ stores 125 in cell 5 of TOM 0 TOM @ . \ retrieves and displays the contents of \ cell 0 of TOM: at this point could be anything \ Version 2 Ham 12:00 11/01/92 1 CONSTANT BYTES WSIZE CONSTANT SINGLES WSIZE 2* CONSTANT DOUBLES : FOR CREATE ( #slots type -) DUP C, * HERE SWAP DUP ALLOT ERASE DOES> ( index <adr> - adr ) COUNT ROT * + ; 11 BYTES FOR FRED \ reserves 11 bytes & zeroes them 35 SINGLES FOR JOAN \ reserves 35*WSIZE bytes & zeroes them 17 DOUBLES FOR JOHN \ reserves 17*2*WSIZE bytes & zeroes them \ These arrays will deliver the address of the slot based \ on the type of the entry. The arrays are initialized to \ zeroes at creation time. \ Version 2, more examples Ham 12:00 11/01/92 \ With this definition, it is the programmer's job to use \ C!, !, 2!, C@, @, and 2@ as appropriate. Note that \ FRED's 11 slots are numbered 0 through 10, JOAN's 35 are \ numbered 0 through 34, and JOHN's 17 are 0 through 16. 213 3 FRED C! \ stores 213 into byte 3 of FRED 31 JOAN @ . \ fetches & displays cell 31 of JOAN 3142352. 15 JOHN 2! \ stores 3142352. into slot 15 of JOHN \ Version 3 Ham 12:00 11/01/92 1 CONSTANT PUT \ flags for the IF statement 0 CONSTANT GET \ in the DOES> part of FOR CREATE STORES ] C! ! 2! [ CREATE FETCHES ] C@ @ 2@ [ : OFFSET ( type - offset ) DUP BYTES = IF DROP 0 THEN ; : FOR CREATE ( #slots type -) DUP C, * HERE SWAP DUP ALLOT ERASE DOES> ( datum 1 ndx <adr> -- | 0 ndx <adr> -- datum ) COUNT DUP >R ( save type ) ROT * + R> OFFSET ROT IF STORES ELSE FETCHES THEN + PERFORM ; \ This version of FOR takes care of the fetching and storing \ given the appropriate flag; the programmer does not have to \ remember whether it is a byte, single-, or double-precision \ array. This could easily be extended for floating-point \ numbers as well. In the stack comment, "|" is read as "or." \ Version 3 examples Ham 12:00 11/01/92 11 BYTES FOR FRED 35 SINGLES FOR JOAN 17 DOUBLES FOR JOHN 213 PUT 3 FRED \ stores 213 in byte 3 of FRED GET 31 JOAN . \ fetches & displays slot 31 of JOAN 3142352. PUT 15 JOHN \ stores 3142352. in slot 15 of JOHN \ Bit tools Ham 12:00 11/01/92 CREATE BITS 1 C, 2 C, 4 C, 8 C, 16 C, 32 C, 64 C, 128 C, : S>B ( ? - f ) 0<> ; \ force to a Boolean flag: -1 or 0 : AIM ( # adr - bit# adr' ) SWAP 8 /MOD ROT + ; : MASK ( bit# - bitmask ) BITS + C@ ; \ BITS contains eight bytes, each with a single bit turned \ on. These are used as masks with AND and OR to manipulate \ a particular bit. \ S>B (single to boolean) converts the bit to a flag (0 or -1). \ Bit tools Ham 12:00 11/01/92 : +BIT ( # adr - ) AIM SWAP MASK OVER C@ OR SWAP C! ; : -BIT ( # adr - ) AIM SWAP MASK NOT OVER C@ AND SWAP C! ; : @BIT ( # adr - f ) AIM C@ SWAP MASK AND S>B ; : ~BIT ( # adr - ) AIM 2DUP @BIT IF -BIT ELSE +BIT THEN ; \ +BIT turns bit on; -BIT turns bit off; @BIT fetches bit as \ a boolean flag; ~BIT (read "toggle bit") toggles the bit. 0 CONSTANT BITS ( used with Version 4 of FOR ) : BITS>BYTES ( #bits - #bytes ) 8 /MOD SWAP IF 1+ THEN ; \ The above word determines the number of bytes needed for a \ bit array of a specified number of bits. \ Version 4 Ham 12:00 11/01/92 : FOR CREATE ( #slots type - ) DUP C, ?DUP IF * ELSE BITS>BYTES THEN HERE SWAP DUP ALLOT ERASE DOES> ( datum 1 ndx <adr> -- | 0 ndx <adr> -- datum ) COUNT ?DUP ( nonzero = numbers; 0 = bits ) IF DUP >R ( stash type ) ROT * + R> OFFSET ROT IF STORES ELSE FETCHES THEN + PERFORM ELSE ( bits ) ROT ( flag: 1 = store, 0 = fetch ) IF ROT ?DUP ( nonzero means a 1 bit or toggle ) IF 0< IF ~BIT ELSE +BIT THEN ELSE -BIT THEN ELSE @BIT THEN THEN ; \ Version 4 examples Ham 12:00 11/01/92 1 1 2CONSTANT SET \ By placing two values on 0 1 2CONSTANT ZAP \ the stack, these words in -1 1 2CONSTANT FLIP \ effect include the PUT. 23 BITS FOR BIT \ reserves 4 bytes for bit array named BIT SET 16 BIT \ turns bit 16 on ZAP 5 BIT \ turns bit 5 off FLIP 0 BIT \ toggles bit 0 GET 3 BIT . \ fetches and displays bit 3 as boolean flag GET 0 BIT . \ fetches and displays bit 0 as boolean flag \ Version 3 examples will also work with this word. \ Version 5 Ham 12:00 11/01/92 : >TYPE ( adr - adr' ; #slots-adr to type-adr ) WSIZE + ; : >DATA ( adr - adr' ; #slots-adr to data-adr ) >TYPE 1+ ; 27 CONSTANT ESC : NUF? ( - f ) ?TERMINAL DUP IF KEY 2DROP KEY ESC = THEN ; \ In version 5, the array will contain TWO pieces of \ information at the beginning: in addition to the type \ of array it is (bit, byte, single, or double) it will \ have a number that specifies the number of slots in the \ array. This number will then be used by a word that can \ take the name of an array and display its contents. \ Version 5 Ham 12:00 11/01/92 : FOR CREATE ( #slots type - ) OVER , ( #slots ) DUP C, ( type ) ?DUP IF * ELSE BITS>BYTES THEN HERE SWAP DUP ALLOT ERASE DOES> ( datum 1 ndx <adr> -- | 0 ndx <adr> -- datum ) >TYPE COUNT ?DUP ( nonzero = numbers; 0 = bits ) IF DUP >R ( save size ) ROT * + R> OFFSET ROT IF STORES ELSE FETCHES THEN + PERFORM ELSE ( bits ) ROT ( flag: 1 = store, 0 = fetch ) IF ROT ?DUP ( nonzero means 1 bit or toggle ) IF 0< IF ~BIT ELSE +BIT THEN ELSE -BIT THEN ELSE @BIT THEN THEN ; \ Version 5 display tools Ham 12:00 11/01/92 CREATE "TYPES ," bit byte single double" : .TYPE ( type - ) DUP BYTES > IF WSIZE / 2* THEN 6 * "TYPES + 6 -TRAILING TYPE ; : LARGE? ( type - f ) 3 > ; \ true = slot is 4 bytes or more : DOUBLE? ( type - f ) WSIZE > ; \ true = double-precision : }LINE ( type n - type ) OVER LARGE? IF DUP 5 ELSE DUP 10 THEN MOD IF DROP ELSE CR 4 .R ." | " THEN ; : VITALS ( array-adr - data-adr #slots type ) DUP >TYPE OVER >DATA ROT @ ( #slots ) ROT C@ ( type ) ; : .TITLE ( #slots type - ) CR CR SWAP . .TYPE ." s:" ; \ Version 5 display tools Ham 12:00 11/01/92 : .NUMBER ( data-adr #slots type - ) SWAP 0 DO I }LINE 2DUP I * + ( adr ) OVER DUP >R ( stash type ) OFFSET FETCHES + PERFORM R> ( retrieve type ) DUP LARGE? IF 12 ELSE 7 THEN \ big # means big space SWAP DOUBLE? IF D.R ELSE .R THEN \ double means D.R NUF? IF LEAVE THEN LOOP 2DROP ; : .BIT ( data-adr #slots - ) 0 DO 2 SPACES BITS I }LINE DROP I OVER @BIT IF ASCII 1 ELSE ASCII - THEN EMIT NUF? IF LEAVE THEN LOOP DROP ; : DISPLAY ( adr -- ) VITALS 2DUP .TITLE ?DUP IF .NUMBER ELSE .BIT THEN CR ; \ Version 5 display word Ham 12:00 11/01/92 : SPILL ( - ; name ) BL WORD FIND IF >BODY DISPLAY ELSE DROP CR ." No such array " THEN ; \ Version 5 examples: double precision Ham 12:00 11/01/92 16 DOUBLES FOR MIKE 1892735. PUT 0 MIKE 7802472. PUT 15 MIKE 1263. PUT 8 MIKE \ SPILL MIKE \ produces the following display (with last column squeezed in) \ 16 doubles: \ 0 | 1892735 0 0 0 0\ 5 | 0 0 0 1263 0\ 10 | 0 0 0 0 0\ 15 | 7802472 \ Version 5 examples: bit array Ham 12:00 11/01/92 17 BITS FOR STEVE SET 0 STEVE SET 15 STEVE FLIP 11 STEVE SPILL STEVE \ produces the following display: \ 17 bits: \ 0 | 1 - - - - - - - - - \ 10 | - 1 - - - 1 - \ Version 6 Ham 12:00 11/01/92 : FOR CREATE ( #slots type - ) DEPTH 2 < ABORT" Specify no. of slots and size of slot." OVER , ( #slots ) DUP C, ( type ) ?DUP IF * ELSE BITS>BYTES THEN HERE SWAP DUP ALLOT ERASE DOES> ( datum 1 ndx <adr> -- | 0 ndx <adr> -- datum ) >TYPE COUNT ?DUP ( nonzero = numbers; 0 = bits ) IF DUP >R ( save size ) ROT * + R> OFFSET ROT IF STORES ELSE FETCHES THEN + PERFORM ELSE ( bits ) ROT ( flag: 1 = store, 0 = fetch ) IF ROT ?DUP ( nonzero means 1 bit or toggle ) IF 0< IF ~BIT ELSE +BIT THEN ELSE -BIT THEN ELSE @BIT THEN THEN ; \ Version 6 includes stack depth error check at creation time.
